Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/common2r/sendbug.frm

Visual Basic Form | 1999-08-27 | 8.6 KB | 262 lines

VERSION 5.00
Begin VB.Form Form7
   Appearance      =   0  '2D
   BackColor       =   &H00808080&
   BorderStyle     =   0  'Kein
   Caption         =   "Send Bug Report"
   ClientHeight    =   3192
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3192
   ScaleWidth      =   4680
   StartUpPosition =   2  'Bildschirmmitte
   Begin VB.TextBox DataArrival
      Appearance      =   0  '2D
      Height          =   288
      Left            =   960
      TabIndex        =   3
      Text            =   "Text1"
      Top             =   2760
      Visible         =   0   'False
      Width           =   1212
   End
   Begin VB.CommandButton Exit
      Appearance      =   0  '2D
      Caption         =   "Exit"
      Height          =   255
      Left            =   2280
      TabIndex        =   2
      Top             =   2880
      Width           =   2295
   End
   Begin VB.CommandButton SendBugConnect
      Appearance      =   0  '2D
      Caption         =   "Send Feedback"
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Top             =   2880
      Width           =   2055
   End
   Begin VB.TextBox Bugreporttxt
      Appearance      =   0  '2D
      Height          =   2655
      Left            =   120
      MultiLine       =   -1  'True
      TabIndex        =   0
      Top             =   120
      Width           =   4455
   End
Attribute VB_Name = "Form7"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*******************************************
'*New Updates:
'-Api Declarations! (needs no Winsock.ocx)
'-Check if the Server respond with the right code
'-Perform a better error check
'-Use a better timeout routine to check if the Server
'times out
'*******************************************
Option Explicit
Private bTrans As Boolean
Private m_iStage As Integer
Private Sock As Integer
Private RC As Integer
Private Bytes As Integer
Private ResponseCode As Integer
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'CHANGE THIS SETTING LIKE YOU NEED IT
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Private Const mailserver As String = "127.0.0.1"
Private Const Tobox As String = "[e-mail]"
Private Const Frombox As String = "[e-mail]"
Private Const Subject As String = "User Feedback!"
'This is for the WaitforResponse Routine
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
'***************************************************************
'Routine for connecting to the server
'***************************************************************
Sub SendBugConnect_Click()
Dim StartupData As WSADataType
Dim SocketBuffer As sockaddr
Dim IpAddr As Long
'Ini the Winsocket
RC = WSAStartup(&H101, StartupData)
RC = WSAStartup(&H101, StartupData)
'Open a free Socket (with this source code you can also
'open several connections! Very useful for E-Mail Applications...)
Sock = socket(AF_INET, SOCK_STREAM, 0)
If Sock = SOCKET_ERROR Then
    MsgBox "Cannot Create Socket."
    Exit Sub
End If
'Checks if the Hostname exists
If RC = SOCKET_ERROR Then Exit Sub
IpAddr = GetHostByNameAlias(mailserver)
If IpAddr = -1 Then
    MsgBox "Unknown Host: " + mailserver
    Exit Sub
End If
'This part is responsible for the connection
SocketBuffer.sin_family = AF_INET
SocketBuffer.sin_port = htons(25)
SocketBuffer.sin_addr = IpAddr
SocketBuffer.sin_zero = String$(8, 0)
RC = connect(Sock, SocketBuffer, Len(SocketBuffer))
'If an error occured close the connection and
'send an error message to the text window
If RC = SOCKET_ERROR Then
        MsgBox "Cannot Connect to " + mailserver + _
                            Chr$(13) + Chr$(10) + _
                            GetWSAErrorString(WSAGetLastError())
        closesocket Sock
        RC = WSACleanup()
        Exit Sub
End If
'Select Receive Window
RC = WSAAsyncSelect(Sock, DataArrival.hWnd, _
                        ByVal &H202, ByVal FD_READ Or FD_CLOSE)
    If RC = SOCKET_ERROR Then
        MsgBox "Cannot Process Asynchronously."
        closesocket Sock
        RC = WSACleanup()
        Exit Sub
    End If
bTrans = True
m_iStage = 0
DataArrival = ""
ResponseCode = 220
Call WaitForResponse
End Sub
'***************************************************************
'Transmit the E-Mail
'***************************************************************
Private Sub Transmit(iStage As Integer)
Dim Helo As String, temp As String
Dim pos As Integer
Select Case m_iStage
Case 1:
    Helo = Frombox
    pos = Len(Helo) - InStr(Helo, "@")
    Helo = Right$(Helo, pos)
    ResponseCode = 250
    WinsockSendData ("HELO " & Helo & vbCrLf)
    Call WaitForResponse
Case 2:
    ResponseCode = 250
    WinsockSendData ("MAIL FROM: <" & Trim(Frombox) & ">" & vbCrLf)
    Call WaitForResponse
Case 3:
    ResponseCode = 250
    WinsockSendData ("RCPT TO: <" & Trim(Tobox) & ">" & vbCrLf)
    Call WaitForResponse
Case 4:
    ResponseCode = 354
    WinsockSendData ("DATA" & vbCrLf)
    Call WaitForResponse
Case 5:
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'If you want additional Headers like Date,Message-Id,...etc. !
'simply add them below                                      !
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    temp = temp & "From: " & Frombox & vbNewLine
    temp = temp & "To: " & Tobox & vbNewLine
    temp = temp & "Subject: " & Subject & vbNewLine
    'Header + Message
    temp = temp & vbCrLf & Bugreporttxt.Text
    'Send the Message & close connection
    WinsockSendData (temp)
    WinsockSendData (vbCrLf & "." & vbCrLf)
    ResponseCode = 250
    Call WaitForResponse
Case 6:
    WinsockSendData ("QUIT" & vbCrLf)
    ResponseCode = 221
    Call WaitForResponse
    m_iStage = 0
    bTrans = False
End Select
End Sub
'***************************************************************
'Routine for arraving Data
'***************************************************************
Private Sub DataArrival_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim MsgBuffer As String * 2048
On Error Resume Next
    If Sock > 0 Then
        'Receive up to 2048 chars
        Bytes = recv(Sock, ByVal MsgBuffer, 2048, 0)

        If Bytes > 0 Then


        If bTrans Then
            If ResponseCode = Left(MsgBuffer, 3) Then
            MsgBuffer = vbNullString
            m_iStage = m_iStage + 1
            Transmit m_iStage
            Else
                closesocket (Sock)
                RC = WSACleanup()
                Sock = 0
                MsgBox "The Server responds with an unexpected Response Code!", vbOKOnly, "Error!"
                Exit Sub
            End If
        End If
        ElseIf WSAGetLastError() <> WSAEWOULDBLOCK Then
            closesocket (Sock)
            RC = WSACleanup()
            Sock = 0
        End If
    End If
Refresh
End Sub
'**************************************************************
' Waits until time out, while waiting for response
'**************************************************************
Private Sub WaitForResponse()
Dim Start As Integer
Dim Tmr As Integer
'Works with an Api Declaration because it's more precious
Start = timeGetTime
While Bytes > 0
    Tmr = timeGetTime - Start
    DoEvents ' Let System keep checking for incoming response

    'Wait 50 seconds for response
    If Tmr > 50000 Then
        MsgBox "SMTP service error, timed out while waiting for response", 64, "Error!"
        End
    End If
End Sub
Private Sub WinsockSendData(DatatoSend As String)
Dim RC As Integer
Dim MsgBuffer As String * 2048
MsgBuffer = DatatoSend
RC = send(Sock, ByVal MsgBuffer, Len(DatatoSend), 0)
'If an error occurs send an error message and
'reset the winsock
If RC = SOCKET_ERROR Then
    MsgBox "Cannot Send Request." + _
                            Chr$(13) + Chr$(10) + _
                            Str$(WSAGetLastError()) + _
                            GetWSAErrorString(WSAGetLastError())
    closesocket Sock
    RC = WSACleanup()
    Exit Sub
End If
End Sub
Private Sub Exit_Click()
On Error Resume Next
    closesocket Sock
    RC = WSACleanup()
    End
End Sub